home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / files.swg / 0074_Forcing Valid Filename Entry.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-26  |  1.6 KB  |  73 lines
  1. {
  2. Here is a routine I used.  It forces entry of a proper filename,
  3. not quite what you're looking for, but close:
  4. }
  5.  
  6. uses
  7.   Crt;
  8.  
  9. const
  10.   OKFNameChars = ['A'..'Z','a'..'z','0'..'9','$','%','''',
  11.                   '-','@','{','}','~','`','!','#','(',')','&'];
  12.  
  13. procedure Backspace;
  14. begin
  15.   gotoxy(wherex-1,1);write(' ');gotoxy(wherex-1,1);
  16. end;
  17.  
  18. function GetFileName(Prompt : string) : string;
  19. var
  20.   OKCharSet : set of char;
  21.   ch : char;
  22.   Done : boolean;
  23.   Name : string;
  24.   len : byte absolute Name;
  25. begin
  26.   OKCharSet := OKFNameChars + ['.',#8,#13,#27];
  27.   write(Prompt);
  28.   Done := false;
  29.   Name := '';
  30.   repeat
  31.     repeat
  32.       ch := upcase(readkey);
  33.     until (ch in OKCharSet);
  34.     case ch of
  35.       #8 : if len > 0 then begin
  36.              Backspace;
  37.              dec(len);
  38.            end;
  39.       #13 : Done := true;
  40.       #27 : begin
  41.               while len > 0 do begin
  42.                 Backspace;
  43.                 dec(len);
  44.               end;
  45.               Done := true;
  46.             end;
  47.       '.' : if (len > 0)
  48.              and (pos('.',Name) = 0) then begin
  49.               write('.');
  50.               Name := Name + '.';
  51.             end;
  52.       else if ((pos('.',Name) = 0) and (len < 8))
  53.            or (len - pos('.',Name) < 3) then begin
  54.              Name := Name + ch;
  55.              write(ch);
  56.            end;
  57.     end; { case }
  58.   until Done;
  59.   writeln;
  60.   GetFileName := Name;
  61. end;
  62.  
  63. { test follows }
  64. var
  65.   fname : string;
  66.  
  67. begin
  68.   clrscr;
  69.   repeat
  70.     fname := GetFileName('Enter file name: ');
  71.   until fname = '';
  72. end.
  73.